There are two levels worth analyzing in response to this question – trends by species and by intake types. This first figure shows the monthly intake per species across the date range of the provided data, January to August 2020.
# absolute intake - makes much more sense for the overall one, whereas relative are good within-species
var <- 'species'
by_month <- foo %>%
mutate(fact_in = factor(!!sym(var), levels=rev(c('Dog', 'Cat', 'Other')))) %>%
mutate(Time = format(as.Date(intake_date), "%Y-%m")) %>%
group_by(Time, fact_in, .drop=FALSE) %>%
summarise(n = length(fact_in), .groups='drop_last')
p<-ggplot(by_month, aes(x=Time, y=n, group=fact_in, fill=fact_in, text=paste('Count:', n)))+
geom_col(alpha=0.6 , size=0.5, colour="black", position='dodge')+
theme(panel.border=element_rect(colour="black", fill= NA)) +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))+
labs(y = 'Count') +
scale_fill_discrete(name = "Species")
ggplotly(p, tooltip=c('text')) %>% config(displayModeBar = FALSE)
The figure shows a downward trend in dog intake from 1189 in January to a low of 457 in April, staying similarly low in May and June before moderately increasing again in July and August. Presumably, this can be associated with the rise of Covid-19, but more context is needed about the shelter’s policies and the situation in Tuscon to say anything more specific. Cat intake similarly decreased from 390 in January to a low of 182 in April, but remained fairly stable (256-271) between May and August. Other species have much lower numbers; a notable month is June, which peaked with 93 animals, almost twice as much as the second-highest ‘Others’ intake in January (51).
The second level worth visualizing is intake type. I think this is better examined separately for dogs and cats, since looking at them together might overlook trends that cancel each other out on the aggregate (for example, a decrease in stray dogs and increase in stray cats would appear as no change in stray intake).
The following figure shows the number of dogs under the four most prevalent intake types per month. For better readability, I left out rare intake types: Quarantine, Return (which I looked at separately, and they were stable), Pub Assist and Transfer. Note that you can click on the legend to hide/show each category.
absolute_intake_type <- function(spec){
var <- 'src_intake_type'
four_types <- c('DISPO REQ', 'CONFISCATE', 'OWNER SUR', 'STRAY')
by_month <- foo %>% filter(species == spec) %>% filter(src_intake_type %in% four_types) %>%
mutate(fact_in = factor(!!sym(var), levels=four_types)) %>%
mutate(Time = format(as.Date(intake_date), "%Y-%m")) %>%
group_by(Time, fact_in, .drop=FALSE) %>%
summarise(n = length(fact_in), .groups='drop_last')
p <- ggplot(by_month, aes(x=Time, y=n, group=fact_in, fill=fact_in, text=paste('Count:',n)))+
geom_col(alpha=0.6 , size=0.5, colour="black", position='dodge')+
theme(panel.border=element_rect(colour="black", fill= NA)) +
theme(axis.text.x = element_text(angle = 90, vjust = 0.5, hjust=1))+
labs(y = 'Count') +
scale_fill_discrete(name = "Intake Type")
return (ggplotly(p, tooltip = 'text') %>% config(displayModeBar = FALSE))
}
absolute_intake_type('Dog')
A few things stand out for dog intakes:
The following figure is similar, but for cats:
absolute_intake_type('Cat')
We see some similarities and differences here:
When looking at all species together, Tuesday and Wednesday have slightly higher volumes than other days.
# add the variable
foo$weekday <- weekdays(foo$intake_date)
foo$weekday_ord <- factor(foo$weekday, # Change ordering manually
levels = c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday", "Sunday"))
# function for plotting
day_volume <- function(foo){
plot_data <- foo %>% count(weekday_ord)
ggplot(plot_data) + geom_col(aes(x = weekday_ord, y=n)) +
labs(x = 'Day', y = 'Count')+
geom_text(aes(x = weekday_ord, label = sprintf("%.f", n), y= n), vjust=2, colour="white", size=4)
}
day_volume(foo)
When looking at dogs only, they are still higher, but the trend is not apparent. Sunday is relatively lower.
day_volume(foo %>% filter(species == 'Dog'))
Which suggest that for cats we will see it more distinctly, as indeed this figure shows. More specifically, Wednesday is cat day (Thursday following), as Tuesday is calmer than all other days.
day_volume(foo %>% filter(species == 'Cat'))
The missing values, in decreasing order:
Here’s a heat-map showing the number of Found animals per ZIP code! A few ZIP codes in the center of the city stand out and numbers relatively decrease in the outskirts. 85705 and 85706 also stand out as fairly smaller ZIP codes with high intakes (although presumably with a denser population). 114 animals also came from way outside town (85321 - a different shelter?).
# load geometry
geometry <- readRDS('zips.rds')
# just counts
finder_count <- foo %>% filter(src_finders_zip_code!=0) %>% group_by(zip=src_finders_zip_code) %>%
summarise(count = length(src_finders_zip_code), .groups='keep')
found_count <- foo %>% group_by(zip=src_found_zip_code) %>%
summarise(count = length(src_found_zip_code), .groups='keep')
# Merge the counts and name properly
countDF <- inner_join(finder_count,found_count, by='zip')
colnames(countDF) = c('zip', 'countFinder', 'countFound')
countDF$zip = as.character(countDF$zip)
count_sf <- geometry %>% inner_join(countDF, by = "zip")
fix_sf <- function(old_sf){
new_sf <- old_sf %>% st_transform(4326)
names(st_geometry(new_sf)) = NULL
#return (old_sf) # raises warnings that suggests to do the below lines, but still works
return(st_transform(old_sf, '+proj=longlat +datum=WGS84')) # this works well locally but fails there
#return (new_sf) # this works without warning locally, but not on shinyapps
}
pal <- colorBin(palette='Purples', domain = count_sf$countFound, bins = c(0, 50, 100, 200, 500, 1000))
label <- sprintf("<strong>%s</strong><br/>%g %s", count_sf$zip, count_sf$countFound, 'Found Animals') %>%
lapply(htmltools::HTML)
leaflet() %>%
addTiles() %>%
setView(lat = 32.2239217, lng = -110.917225, zoom=8) %>%
addPolygons(data=fix_sf(count_sf), group='Found', fillColor=~pal(countFound),
fillOpacity = 0.7, color='grey', weight = 1, opacity = 0.4, label = label,
highlightOptions = highlightOptions(color = "black",weight = 2, bringToFront = TRUE)) %>%
addLegend(pal = pal, values = count_sf$countFound, opacity = 0.7, title = 'Found Animals',
position = "bottomright", group='Found')